Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Pascal/Utilities/MungeImage 1.2.0/MungeImage.p

Text File | 1994-08-15 | 22.5 KB | 813 lines | [TEXT/PJMM]

unit MungeImage;

interface

    uses
        MungeCommon;

    function Main (dctl: DCtlPtr; pb: mungeParamBlockPtr; sel: integer): OSErr;

implementation

    uses
        Processes, Aliases, FixMath, DartIntf, LZRW1KH, MungeLibs;

    const
        chunk_bytes = 20480;                    (* the chunk size which we load (and compress) images *)
        chunk_k = 20;

    const
        kLZRW1KHCompress = $42;            (* 'our' compression algorithm *)

        max_drive_count = 15;                    (* hardwired limit to the number of floppies you can mount *)
        kOptionKey = 58;
        disk_just_inserted = 1;                    (* some random constants used by the floppy driver *)
        disk_read = 2;                                (* we make some attempt to emulate this behaviour *)

    type
        diskCopyHeader = record                (* this record maps on to the first N bytes of a DiskCopy image file *)
                name: Str63;
                data_size: longint;
                tag_size: longint;
                data_checksum: longint;
                tag_checksum: longint;
                unknown: longint;
            end;

    const
        dataCRCheaderOffset = 72;            (* offset in the header at which to patch in data CRC when writing DiskCopy images *)

    type
        driveRecord = record                    (* a record that holds all the important information about a specific 'drive' *)
                flags: signedByte;                    (* the following 4 bytes must be in order and immediately in front of dqel *)
                disk_in_place: signedByte;
                drive_installed: signedByte;
                number_of_sides: signedByte;
                dqel: DrvQEl;
                image: Ptr;
                disk_size: longint;
                readonly: boolean;                    (* disk is mounted read-only, if false then the image must be an uncompressed DiskCopy image *)
                alias: AliasHandle;                (* an alias to the image file (where a read-write image is written back) *)
                writeout: boolean;
                dart_header: HDSrcInfoRec;    (* contains information about the image,  most importantly the compression used *)
            end;

    (* disk_in_place is 0 iff (image is nil) *)

    type
        iconType = array[0..255] of signedByte;
        physIcon = record
                phys_icon: iconType;
                location_str: Str63;
            end;

    var
        AlreadyOpen: boolean;                    (* the driver is open *)
        phys_icon: physIcon;
        media_icon: iconType;
        drives: array[1..max_drive_count] of driveRecord;

(* The chunk cache is used to reduce the access time by holding one chunk of one disk uncompressed. *)
(* This means that we don't need to uncompress a chunk for each read. If the read is to the same chunk *)
(* as the previous read then the data is already in the chunk_cache *)

(* Read-Write disks can't be compressed and hence the chunk_cache is ignored for them. Thus there is *)
(* no cache dirty bit. *)

(* The chunk cache is actually DDBLOCKSIZE bytes big because we're not entirely sure how the DART image *)
(* decompression code works. The sample we got allocates a DDBLOCKSIZE buffer and we do the same *)
(* for obvious safety reasons. *)

        chunk_cache: Ptr;                            (* pointer to a buffer that holds the cached chunk *)
        cached_drive_ndx: integer;            (* the drive that's being cached *)
        cached_chunk: integer;                    (* the chunk that's being cached *)

    const
        Size_Of_Globals = sizeof(AlreadyOpen) + sizeof(phys_icon) * 2 + sizeof(drives) + sizeof(chunk_cache) + sizeof(cached_drive_ndx) + sizeof(cached_chunk) + $100;

    procedure SetRegA4 (n: univ Ptr);
    inline
        $285F;

    function CreateTrackCache: OSErr;
        var
            err: OSErr;
    begin
        err := noErr;
        if chunk_cache = nil then begin
            chunk_cache := NewPtrSys(DDBLOCKSIZE);
            err := MemError;
            cached_drive_ndx := -1;
        end; (* if *)
        CreateTrackCache := err;
    end; (* CreateTrackCache *)

    procedure DestroyTrackCache;
    begin
        DisposePtr(chunk_cache);
        chunk_cache := nil;
    end; (* DestroyTrackCache *)

    function CalcChecksum (data: Ptr; datasize: longint): longint;
        type
            bigArray = array[0..123456] of integer;
            bigArrayPtr = ^bigArray;
        var
            i: longint;
            word: integer;
            checksum: longint;
    begin
        if odd(datasize) then begin
            DebugStr('datasize shouldnt be odd!');
        end; (* if *)
        checksum := 0;
        for i := 0 to datasize div 2 - 1 do begin
            word := bigArrayPtr(data)^[i];
            checksum := checksum + band(word, $0000FFFF);
            checksum := brotl(checksum, 31);
        end; (* for *)
        CalcChecksum := checksum;
    end; (* CalcChecksum *)

(* ***** Operations on the drive queue and our drives globals ***** *)

    function DriveExists (drive_num: integer): boolean;
        var
            cur_el: DrvQElPtr;
    begin
        DriveExists := false;
        cur_el := DrvQElPtr(GetDrvQHdr^.qHead);
        while cur_el <> nil do begin
            if cur_el^.dQDrive = drive_num then begin
                DriveExists := true;
                leave;
            end; (* if *)
            cur_el := DrvQElPtr(cur_el^.qLink);
        end; (* while *)
    end; (* DriveExists *)

    function FindFreeDriveRecord (var ndx: integer): boolean;
        var
            i: integer;
    begin
        ndx := 0;
        for i := 1 to max_drive_count do begin
            if drives[i].disk_in_place = 0 then begin
                ndx := i;
                leave;
            end; (* if *)
        end; (* for *)
        FindFreeDriveRecord := (ndx <> 0);
    end; (* FindFreeDriveRecord *)

    function DriveToDriveRecord (drive_num: integer; var ndx: integer): OSErr;
        var
            i: integer;
    begin
        ndx := 0;
        for i := 1 to max_drive_count do begin
            if (drives[i].disk_in_place <> 0) and (drives[i].dqel.dQDrive = drive_num) then begin
                ndx := i;
                leave;
            end; (* if *)
        end; (* for *)
        if ndx = 0 then begin
            DriveToDriveRecord := nsDrvErr;
        end
        else begin
            DriveToDriveRecord := noErr;
        end; (* if *)
    end; (* DriveToDriveRecord *)

    function AnyDriveRecordInUse: boolean;
        var
            i: integer;
    begin
        AnyDriveRecordInUse := false;
        for i := 1 to max_drive_count do begin
            if drives[i].disk_in_place <> 0 then begin
                AnyDriveRecordInUse := true;
                leave;
            end; (* if *)
        end; (* for *)
    end; (* AnyDriveRecordInUse *)

    procedure CreateDriveRecord (ndx: integer);
    begin
        drives[ndx].alias := nil;
        drives[ndx].image := nil;
        drives[ndx].disk_in_place := disk_just_inserted;
        drives[ndx].writeout := false;
    end; (* CreateDriveRecord *)

    procedure DestroyDriveRecord (ndx: integer);
    begin
        if drives[ndx].alias <> nil then begin
            DisposeHandle(handle(drives[ndx].alias));
        end;
        if drives[ndx].image <> nil then begin
            DisposePtr(drives[ndx].image);
        end;
        drives[ndx].image := nil;
        drives[ndx].disk_in_place := 0;
        drives[ndx].writeout := false;
        if not AnyDriveRecordInUse then begin
            DestroyTrackCache;
        end; (* if *)
    end; (* DestroyDriveRecord *)

    function ChunkIndexToOffset (var dart_header: HDSrcInfoRec; blockIdx: integer; var offset: longint): OSErr;
        var
            err: OSErr;
            block: integer;
            blockLen: integer;
    begin
        err := noErr;
        offset := 0;
        for block := 1 to blockIdx - 1 do begin
            blockLen := dart_header.bLength[block];
            if (blockLen = -1) then begin
                blockLen := DDBLOCKSIZE;
            end
            else begin
                if (dart_header.srcCmp = kRLECompress) then begin
                    blockLen := blockLen * 2;
                end; (* if *)
            end; (* if *)
            if not ((blockLen > 0) and (blockLen <= DDBLOCKSIZE)) then begin
                err := paramErr; (* oops! bogus block length encountered *)
            end; (* if *)
            offset := offset + blockLen;
        end; (* for *)
        ChunkIndexToOffset := err;
    end; (* ChunkIndexToOffset *)

    function DecompressChunk (var dart_header: HDSrcInfoRec; image, outBlock: Ptr; blockIdx: integer): OSErr;
        var
            err: OSErr;
            offset: longint;
            junk: BufferSize;
    begin
        err := ChunkIndexToOffset(dart_header, blockIdx, offset);
        if err = noErr then begin
            image := Ptr(longint(image) + offset);
            if (dart_header.bLength[blockIdx] <> -1) then begin
                case dart_header.srcCmp of
                    kRLECompress:
                        err := RLEExpandBlock(image, DDPtr(outBlock), dart_header.bLength[blockIdx]);
                    kLZHCompress:
                        err := LZHExpandBlock(image, DDPtr(outBlock), dart_header.bLength[blockIdx]);
                    kLZRW1KHCompress:
                        junk := LZRW1KHDecompress(BufferPtr(image), BufferPtr(outBlock), dart_header.bLength[blockIdx]);
                    kNoCompress:
                        BlockMove(image, outBlock, dart_header.bLength[blockIdx]);
                    otherwise
                        err := paramErr;
                end; (* case *)
            end
            else begin
                BlockMove(image, outBlock, chunk_bytes);
            end; (* if *)
        end; (* if *)
        DecompressChunk := err;
    end; (* DecompressChunk *)

    function Main (dctl: DCtlPtr; pb: mungeParamBlockPtr; sel: integer): OSErr;

        function DoOpen: OSErr;
            var
                err: OSErr;
                i: integer;
                junk: OSErr;
        begin
            err := noErr;
            if dctl^.dCtlStorage = nil then begin
                dctl^.dCtlStorage := NewHandleSysClear(Size_Of_Globals);
                err := MemError;
                if err = noErr then begin
                    HLock(dctl^.dCtlStorage);
                    SetRegA4(dctl^.dCtlStorage^);
                end;
            end;
            if (err = noErr) & not AlreadyOpen then begin
                AlreadyOpen := true;
            end;
            if (err = noErr) then begin
                phys_icon.location_str := GetString(128)^^;
                BlockMove(GetResource('ICN#', 200)^, @phys_icon.phys_icon, sizeof(iconType));
                BlockMove(GetResource('ICN#', 201)^, @media_icon, sizeof(media_icon));
                for i := 1 to max_drive_count do begin
                    drives[i].disk_in_place := 0;
                    drives[i].image := nil;
                end; (* for *)
            end; (* if *)
            chunk_cache := nil;
            DoOpen := err;
        end; (* DoOpen *)

        function CallProgressProc (pb: mungeParamBlockPtr; proc: ProcPtr): OSErr;
        inline
            $205F, (* move.l    (a7)+,a0        ; pop proc address        *)
            $4E90; (* jsr            (a0)            ; call proc                    *)

        function CallProgress (progress_done, progress_total: longint): OSErr;
            var
                err: OSErr;
        begin
            err := noErr;
            if pb^.progress <> nil then begin
                pb^.progress_done := FracDiv(progress_done, progress_total);
                err := CallProgressProc(pb, pb^.progress);
            end; (* if *)
            CallProgress := err;
        end; (* CallProgress *)

        function ReadDARTFile (ndx: integer; refnum: integer): OSErr;
            var
                err: OSErr;
                i: integer;
                total_chunks: integer;
                file_size: longint;
                count: longint;
                offset: longint;
                bytes: longint;
        begin
            err := FSReadQ(refnum, sizeof(drives[ndx].dart_header), @drives[ndx].dart_header);

            if err = noErr then begin
                if not (drives[ndx].dart_header.srcType in [kMacHiDDisk, kMSDOSHiDDisk]) then begin
                    err := SetFPos(refnum, fsFromStart, sizeof(SrcInfoRec));
                end; (* if *)
            end; (* if *)

            if err = noErr then begin
                total_chunks := drives[ndx].dart_header.srcSize div chunk_k;
                if total_chunks > 72 then begin
                    err := paramErr;
                end; (* if *)
            end; (* if *)
            if err = noErr then begin
                err := ChunkIndexToOffset(drives[ndx].dart_header, total_chunks + 1, file_size);
            end; (* if *)
            if err = noErr then begin
                drives[ndx].disk_size := longint(drives[ndx].dart_header.srcSize) * 1024;
                drives[ndx].image := NewPtrSys(file_size);
                err := MemError;
            end; (* if *)
            if err = noErr then begin
                offset := 0;
                while (offset < file_size) and (err = noErr) do begin
                    bytes := file_size - offset;
                    if bytes > chunk_bytes then begin
                        bytes := chunk_bytes;
                    end; (* if *)
                    err := FSReadQ(refnum, bytes, Ptr(longint(drives[ndx].image) + offset));
                    offset := offset + bytes;
                    if err = noErr then begin
                        err := CallProgress(offset, file_size);
                    end; (* if *)
                end; (* while *)
            end; (* if *)
            ReadDARTFile := err;
        end; (* ReadDARTFile *)

        function ReadDiskCopyFile (ndx: integer; refnum: integer; readonly: boolean): OSErr;
            var
                err: OSErr;
                header: diskCopyHeader;
                i: integer;
                offset: longint;
                compressed_size: integer;
        begin
            err := FSReadQ(refnum, sizeof(header), @header);
            if err = noErr then begin
                if header.data_size div chunk_bytes > 72 then begin
                    err := paramErr;
                end; (* if *)
            end; (* if *)
            if err = noErr then begin
                drives[ndx].disk_size := header.data_size;
                drives[ndx].image := NewPtrSys(drives[ndx].disk_size + 72);
                err := MemError;
            end; (* if *)
            if err = noErr then begin
                cached_drive_ndx := -1;
                offset := 0;
                for i := 1 to header.data_size div chunk_bytes do begin
                    err := FSReadQ(refnum, chunk_bytes, chunk_cache);
                    if err = noErr then begin
                        if readonly then begin
                            compressed_size := LZRW1KHCompress(BufferPtr(chunk_cache), BufferPtr(longint(drives[ndx].image) + offset), chunk_bytes);
                        end
                        else begin
                            BlockMove(chunk_cache, Ptr(longint(drives[ndx].image) + offset), chunk_bytes);
                            compressed_size := chunk_bytes;
                        end; (* if *)
                        drives[ndx].dart_header.bLength[i] := compressed_size;
                        offset := offset + compressed_size;
                    end; (* if *)
                    if err = noErr then begin
                        err := CallProgress(i, header.data_size div chunk_bytes);
                    end; (* if *)
                    if err <> noErr then begin
                        leave;
                    end; (* if *)
                end; (* for *)
                if err = noErr then begin
                    SetPtrSize(drives[ndx].image, offset);
                    err := MemError;
                    if err <> noErr then begin
                        DebugStr('Pete is extremely skeptical!');
                    end; (* if *)
                end; (* if *)
            end; (* if *)
            if err = noErr then begin
                with drives[ndx].dart_header do begin (* safe *)
                    if readonly then begin
                        srcCmp := kLZRW1KHCompress;
                    end
                    else begin
                        srcCmp := kNoCompress;
                    end; (* if *)
                    srcType := 0;
                    srcSize := header.data_size div 1024;
                end; (* with *)
            end; (* if *)
            ReadDiskCopyFile := err;
        end; (* ReadDiskCopyFile *)

        function MountImage: OSErr;
            var
                err: OSErr;
                junk: OSErr;
                ndx: integer;
                refnum: integer;
                drive_num: integer;
                readonly: boolean;
                oldzone: THz;
                file_info: FInfo;
        begin
            readonly := not btst(pb^.mount_flags, mf_read_write);
            err := CreateTrackCache;
            ndx := 0;        (* important safety tip! *)
            if not FindFreeDriveRecord(ndx) then begin
                err := -666;
            end
            else begin
                CreateDriveRecord(ndx);
                if err = noErr then begin
                    err := FSpOpenDF(pb^.file_to_mount^, fsRdPerm, refnum);
                    if err = noErr then begin
                        err := FSpGetFInfo(pb^.file_to_mount^, file_info);

                        if err = noErr then begin
                            if file_info.fdType = kDiskCopyType then begin
                                err := ReadDiskCopyFile(ndx, refnum, readonly);
                            end
                            else begin
                                err := ReadDARTFile(ndx, refnum);
                                readonly := true;
                            end;
                        end; (* if *)

                        junk := FSClose(refnum);
                    end;
                end; (* if *)

                if not readonly then begin
                    oldzone := GetZone;
                    SetZone(SystemZone);
                    if NewAlias(nil, pb^.file_to_mount^, drives[ndx].alias) <> noErr then begin
                        drives[ndx].alias := nil;
                    end; (* if *)
                    SetZone(oldzone);
                end;

                if err = noErr then begin (* mount the image *)
                    drive_num := 4;
                    while DriveExists(drive_num) do begin
                        drive_num := drive_num + 1;
                    end; (* while *)
                    drives[ndx].readonly := readonly;
                    drives[ndx].flags := signedByte($80 * ord(readonly));
                    drives[ndx].drive_installed := 0;
                    drives[ndx].number_of_sides := 0;            (* ? should set to 0 for 400K disk images*)
                    drives[ndx].dqel.qType := 1;
                    drives[ndx].dqel.dQDrive := drive_num;
                    drives[ndx].dqel.dQRefNum := pb^.ioCRefNum;
                    drives[ndx].dqel.dQFSID := 0;
                    drives[ndx].dqel.dQDrvSz := drives[ndx].disk_size div 512;
                    drives[ndx].dqel.dQDrvSz2 := 0;
                    AddDrive(dctl^.dCtlRefNum, drive_num, @drives[ndx].dqel);
                    junk := PostEvent(diskEvt, drive_num);
                end
                else begin
                    DestroyDriveRecord(ndx);
                end; (* if *)
                InitCursor;
            end; (* if *)
            MountImage := err;
        end; (* MountImage *)

        procedure WriteBack (ndx: integer);
            var
                err: OSErr;
                aliascount: integer;
                fss: array[1..2] of FSSPec;
                needsUpdate: boolean;
                rn: integer;
                crc: longInt;
        begin
            aliascount := 2;
            err := MatchAlias(nil, kARMNoUI + kARMSearch, drives[ndx].alias, aliascount, @fss, needsUpdate, nil, nil);
            if (err = noErr) & (aliascount <> 1) then begin
                err := -1;
            end; (* if *)
            if err = noErr then begin
                err := FSpOpenDF(fss[1], fsRdWrPerm, rn);
                if err = noErr then begin
                    err := MyFSWriteAt(rn, fsFromStart, SizeOf(diskCopyHeader), drives[ndx].disk_size, drives[ndx].image);
                    if err = noErr then begin
                        crc := CalcChecksum(drives[ndx].image, drives[ndx].disk_size);
                        err := MyFSWriteAt(rn, fsFromStart, dataCRCheaderOffset, SizeOf(crc), @crc);
                    end; (* if *)
                    err := FSClose(rn);
                end; (* if *)
            end; (* if *)
        end; (* WriteBack *)

        function UnMountImage: OSErr;
            var
                err: OSErr;
                junk: OSErr;
                ndx: integer;
        begin
            err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
            if err = noErr then begin
                if ndx = cached_drive_ndx then begin
                    cached_drive_ndx := -1;
                end; (* if *)
                if DeQueue(@drives[ndx].dqel, GetDrvQHdr) <> noErr then begin
                    DebugStr('Hmm, removing a non-existant drive');
                end; (* if *)
                if not drives[ndx].readonly then begin
                    drives[ndx].writeout := true;
                end
                else begin
                    DestroyDriveRecord(ndx);
                end;
            end; (* if *)
            UnMountImage := err;
        end; (* UnMountImage *)

        function DoClose: OSErr;
            var
                err: OSErr;
        begin
            if AnyDriveRecordInUse then begin
                err := closErr;
            end
            else begin
                if chunk_cache <> nil then begin
                    DebugStr('Pete lied!');
                end; (* if *)
                err := noErr;
            end; (* if *)
            DoClose := err;
        end; (* DoClose *)

        function ReadCachedChunk (ndx: integer; chunk: integer): OSErr;
            var
                err: OSErr;
        begin
            err := noErr;
            if (ndx <> cached_drive_ndx) or (chunk <> cached_chunk) then begin
                err := DecompressChunk(drives[ndx].dart_header, drives[ndx].image, chunk_cache, chunk);
                if err = noErr then begin
                    cached_chunk := chunk;
                    cached_drive_ndx := ndx;
                end
                else begin
                    cached_drive_ndx := -1;
                end; (* if *)
            end; (* if *)
            ReadCachedChunk := err;
        end; (* ReadCachedChunk *)

        function ReadCached (ndx: integer; offset: longint; buffer: Ptr; count: longint): OSErr;
            var
                err: OSErr;
                cur_chunk: integer;
                bytes_in_this_chunk: longint;
                bytes_to_do: longint;
        begin
            err := noErr;
            while (count > 0) and (err = noErr) do begin
                cur_chunk := offset div chunk_bytes + 1;
                err := ReadCachedChunk(ndx, cur_chunk);
                if err = noErr then begin
                    bytes_in_this_chunk := longint(cur_chunk) * chunk_bytes - offset;
                    if bytes_in_this_chunk > count then begin
                        bytes_to_do := count;
                    end
                    else begin
                        bytes_to_do := bytes_in_this_chunk;
                    end; (* if *)
                    BlockMove(Ptr(longint(chunk_cache) + chunk_bytes - bytes_in_this_chunk), buffer, bytes_to_do);
                    offset := offset + bytes_to_do;
                    buffer := Ptr(longint(buffer) + bytes_to_do);
                    count := count - bytes_to_do;
                end; (* if *)
            end; (* while *)
            ReadCached := err;
        end; (* ReadCached *)

        function DoPrime: OSErr;
            var
                err: OSErr;
                offset: longint;
                ndx: integer;
        begin
            err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
            if err = noErr then begin
                offset := dctl^.dCtlPosition;
                if (offset < 0) or (pb^.ioReqCount < 0) or (offset + pb^.ioReqCount > drives[ndx].disk_size) then begin
                    pb^.ioActCount := 0;
                    err := paramErr;
                end
                else begin
                    err := noErr;
                    pb^.ioActCount := 0;
                    if odd(pb^.ioTrap) then begin
                        (* write *)
                        if drives[ndx].readonly then begin
                            err := wPrErr;
                        end
                        else begin
                            BlockMove(pb^.ioBuffer, Ptr(ord(drives[ndx].image) + offset), pb^.ioReqCount);
                        end;
                    end
                    else begin
                        (* read *)
                        drives[ndx].disk_in_place := disk_read;
                        if drives[ndx].readonly then begin
                            err := ReadCached(ndx, offset, pb^.ioBuffer, pb^.ioReqCount);
                        end
                        else begin
                            (* read-write disks are always uncompressed (and hence uncached) *)
                            BlockMove(Ptr(ord(drives[ndx].image) + offset), pb^.ioBuffer, pb^.ioReqCount);
                        end; (* if *)
                    end; (* if *)
                    if err = noErr then begin
                        pb^.ioActCount := pb^.ioReqCount;
                        dctl^.dCtlPosition := dctl^.dCtlPosition + pb^.ioActCount;
                    end;
                end; (* if *)
            end; (* if *)
            DoPrime := err;
        end; (* DoPrime *)

        procedure DoAccRun;
            var
                i: integer;
        begin
            for i := 1 to max_drive_count do begin
                if drives[i].disk_in_place <> 0 then begin
                    if drives[i].writeout then begin
                        WriteBack(i);
                        DestroyDriveRecord(i);
                    end;
                end;
            end;
        end;

        function DoControl: OSErr;
            const
                super_drive_info = $00000404;
            var
                err: OSErr;
                keys: KeyMap;
        begin
            case pb^.csCode of
                1:
                    err := -1; (* KillIO *)
                5:
                    err := noErr; (* Verify Disk *)
                6:
                    err := noErr; (* Format Disk *)
                7:
                    err := UnMountImage; (* Eject Disk *)
                8:
                    if pb^.ioMisc = nil then begin    (* Set Tag Buffer *)
                        err := noErr;
                    end
                    else begin
                        err := -1;
                    end; (* if *)
                9:
                    err := -1; (* Track Cache Control *)
                21:  begin    (* Return Physical Icon *)
                    pb^.ioMisc := @phys_icon;
                    err := noErr;
                end;
                22:  begin    (* Return Media Icon *)
                    pb^.ioMisc := @media_icon;
                    err := noErr;
                end;
                23:  begin (* Return Drive Info *)
                    pb^.ioMisc := Ptr(super_drive_info);
                    err := noErr;
                end;
                accRun:
                    DoAccRun;
                csMountImage:  begin
                    pb^.progress := nil;
                    pb^.mount_flags := 0;
                    GetKeys(keys);
                    if keys[kOptionKey] then begin
                        bset(pb^.mount_flags, mf_read_write);
                    end; (* if *)
                    err := MountImage;
                end;
                csMountImageWithProgress:  begin
                    err := MountImage;
                end;
                667:
                    err := noErr;
                18244:  begin
                    err := -1;
                end;
                otherwise
                    err := controlErr;
            end; (* case *)
            DoControl := err;
        end; (* DoControl *)

        function DoStatus: OSErr;
            const
                mfm_1440_capacity = 1440 * 2;
                mfm_1440_stuff = $D2120050;
            var
                err: OSErr;
                ndx: integer;
        begin
            case pb^.csCode of
                6:  begin (* Return Format List *)
                    err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
                    if err = noErr then begin
                        with pb^ do begin
                            if format_count > 0 then begin
                                format_count := 1;
                                format_point^.capacity := drives[ndx].disk_size div 512;
                                format_point^.stuff := 0;
                                err := noErr;
                            end
                            else begin
                                err := paramErr;
                            end; (* if *)
                        end; (* with *)
                    end; (* if *)
                end;
                8:  begin
                    err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
                    if err = noErr then begin
                        with pb^ do begin
                            status_current_track := 0;
                            status_flags := drives[ndx].flags;
                            status_disk_in_place := drives[ndx].disk_in_place;
                            status_drive_installed := drives[ndx].drive_installed;
                            status_number_of_sides := drives[ndx].number_of_sides;
                            status_dqel := drives[ndx].dqel;
                            status_dqel.dQDrvSz := -1;
                            status_dqel.dQDrvSz2 := 0;
                        end; (* with *)
                        err := noErr;
                    end; (* if *)
                end;
                otherwise
                    err := controlErr;
            end; (* case *)
            DoStatus := err;
        end; (* DoStatus *)

        var
            err: OSErr;
    begin
        case sel of
            0:
                err := DoOpen;
            1:
                err := DoPrime;
            2:
                err := DoControl;
            3:
                err := DoStatus;
            4:
                err := DoClose;
            otherwise
                err := noErr;
        end; (* case *)
        Main := err;
    end; (* Main *)

end. (* MungeImage *)